Attribute VB_Name = "modRichError"
'***************************************************************
' (c) Copyright 2000 Matthew J. Curland
'
' This file is from the CD-ROM accompanying the book:
' Advanced Visual Basic 6: Power Techniques for Everyday Programs
'   Author: Matthew Curland
'   Published by: Addison-Wesley, July 2000
'   ISBN: 0-201-70712-8
'   http://www.PowerVB.com
'
' You are entitled to license free distribution of any application
'   that uses this file if you own a copy of the book, or if you
'   have obtained the file from a source approved by the author. You
'   may redistribute this file only with express written permission
'   of the author.
'
' This file depends on:
'   References:
'     VBoostTypes6.olb (VBoost Object Types (6.0))
'     VBoost6.Dll (VBoost Object Implementation (6.0)) (optional)
'   Files:
'     VBoost.Bas (optional)
'   Minimal VBoost conditionals:
'     VBOOST_INTERNAL = 1 : VBOOST_CUSTOM = 1
'   Conditional Compilation Values:
'     NOVBOOST = 1 'Removes VBoost dependency
'
' This file is discussed in Chapter 8.
'***************************************************************
Option Explicit

Private Declare Function SetErrorInfo Lib "oleaut32.dll" (ByVal dwReserved As Long, perrinfo As Long) As Long
Private Type RichErrorVTables
    SEI(3) As Long 'ISupportErrorInfo
    EI(7) As Long  'IErrorInfo
End Type
Private m_VTables As RichErrorVTables

'Structure and singleton for IErrorInfo implementation
Private Type ErrorInfo
    pVTable As Long
    cRefs As Long
    Source As String
    Description As String
    HelpFile As String
    HelpContext As Long
End Type
Private m_ErrorInfo As ErrorInfo

'VTable and singleton for ISupportErrorInfo.
'The vtable is the only required element, so there
'is no reason to bother with a structure.
Private m_pSEIVTable As Long
Private m_pSupportErrorInfo As Long

Private IID_IUnknown As VBoostTypes.VBGUID
Private IID_IErrorInfo As VBoostTypes.VBGUID
Private IID_ISupportErrorInfo As VBoostTypes.VBGUID

'Provides a quick check to determine if a call
'to CheckErrorInfo is indicated.
Public Const ISupportErrorInfo_Data1 As Long = &HDF0B3D60

Public Function MapError() As Long
Dim Number As Long
    Number = Err.Number
    If Number Then
        If Number > 0 Then Number = &H800A0000 Or Number
        MapError = Number
    End If
End Function

Public Function MapErrorKeepRich() As Long
Dim Number As Long
    With Err
        Number = .Number
        If Number Then
            If Number > 0 Then Number = &H800A0000 Or Number
            If m_pSupportErrorInfo = 0 Then Init
            m_ErrorInfo.Source = .Source
            m_ErrorInfo.Description = .Description
            m_ErrorInfo.HelpFile = .HelpFile
            m_ErrorInfo.HelpContext = .HelpContext
            .Clear
            SetErrorInfo 0, m_ErrorInfo.pVTable
            MapErrorKeepRich = Number
        End If
    End With
End Function
Public Sub ClearErrorInfo()
    If m_ErrorInfo.cRefs Then SetErrorInfo 0, ByVal 0&
End Sub
Public Function CheckErrorInfo(hr As Long, riid As VBoostTypes.VBGUID, pvObj As Long) As Boolean
    'This check should be done before calling the function
    'If riid.Data1 = ISupportErrorInfo_Data1 Then
    If m_ErrorInfo.cRefs = 0 Then Exit Function
    If IsEqualGUID(riid, IID_ISupportErrorInfo) Then
        pvObj = m_pSupportErrorInfo
        hr = 0
        CheckErrorInfo = True
    End If
End Function
Private Sub Init()
    Debug.Assert m_pSupportErrorInfo = 0
    IID_IErrorInfo = IIDFromString(strIID_IErrorInfo)
    IID_ISupportErrorInfo = IIDFromString(strIID_ISupportErrorInfo)
    IID_IUnknown = IIDFromString(strIID_IUnknown)
    With m_VTables
        .SEI(0) = FuncAddr(AddressOf SEIQueryInterface)
        .SEI(1) = FuncAddr(AddressOf SEIAddRefRelease)
        .SEI(2) = .SEI(1)
        .SEI(3) = FuncAddr(AddressOf InterfaceSupportsErrorInfo)
        m_pSEIVTable = VarPtr(.SEI(0))
        m_pSupportErrorInfo = VarPtr(m_pSEIVTable)
        
        .EI(0) = FuncAddr(AddressOf IEIQueryInterface)
        .EI(1) = FuncAddr(AddressOf IEIAddRef)
        .EI(2) = FuncAddr(AddressOf IEIRelease)
        .EI(3) = FuncAddr(AddressOf IEIGetGUID)
        .EI(4) = FuncAddr(AddressOf IEIGetSource)
        .EI(5) = FuncAddr(AddressOf IEIGetDescription)
        .EI(6) = FuncAddr(AddressOf IEIGetHelpFile)
        .EI(7) = FuncAddr(AddressOf IEIGetHelpContext)
        m_ErrorInfo.pVTable = VarPtr(.EI(0))
    End With
End Sub

Private Function SEIQueryInterface(ByVal This As Long, riid As VBoostTypes.VBGUID, pvObj As Long) As Long
Dim fOK As BOOL
    Select Case riid.Data1
        Case 0
            fOK = IsEqualIID(riid, IID_IUnknown)
        Case ISupportErrorInfo_Data1
            fOK = IsEqualIID(riid, IID_ISupportErrorInfo)
    End Select
    If fOK Then
        pvObj = This
    Else
        pvObj = 0
        SEIQueryInterface = E_NOINTERFACE
    End If
End Function
Private Function SEIAddRefRelease(This As Long) As Long
    SEIAddRefRelease = 1
End Function

Private Function InterfaceSupportsErrorInfo(This As Long, riid As VBoostTypes.VBGUID) As Long
    If m_ErrorInfo.cRefs = 0 Then InterfaceSupportsErrorInfo = E_FAIL
End Function

Private Function IEIQueryInterface(This As ErrorInfo, riid As VBoostTypes.VBGUID, pvObj As Long) As Long
Dim fOK As BOOL
    Select Case riid.Data1
        Case 0
            fOK = IsEqualIID(riid, IID_IUnknown)
        Case &H1CF2B120 'IErrorInfo_Data1
            fOK = IsEqualIID(riid, IID_IErrorInfo)
    End Select
    If fOK Then
        With This
            pvObj = VarPtr(.pVTable)
            .cRefs = .cRefs + 1
        End With
    Else
        pvObj = 0
        IEIQueryInterface = E_NOINTERFACE
    End If
End Function
Private Function IEIAddRef(This As ErrorInfo) As Long
    With This
        .cRefs = .cRefs + 1
        IEIAddRef = .cRefs
    End With
End Function
Private Function IEIRelease(This As ErrorInfo) As Long
    With This
        .cRefs = .cRefs - 1
        IEIRelease = .cRefs
    End With
End Function
Private Function IEIGetGUID(This As Long, ByRef riid As VBoostTypes.VBGUID) As Long
    'Be happy with GUID_NULL. VB doesn't call this anyway.
End Function
Private Function IEIGetSource(This As ErrorInfo, pBstrSource As Long) As Long
    pBstrSource = 0
    #If NOVBOOST Then
        Dim pSource As Long
        pSource = VarPtr(This.Source)
        CopyMemory pBstrSource, ByVal pSource, 4
        CopyMemory ByVal pSource, 0&, 4
    #Else
        VBoost.AssignSwap pBstrSource, This.Source
    #End If
End Function
Private Function IEIGetDescription(This As ErrorInfo, pBstrDescription As Long) As Long
    pBstrDescription = 0
    #If NOVBOOST Then
        Dim pDesc As Long
        pDesc = VarPtr(This.Description)
        CopyMemory pBstrDescription, ByVal pDesc, 4
        CopyMemory ByVal pDesc, 0&, 4
    #Else
        VBoost.AssignSwap pBstrDescription, This.Description
    #End If
End Function
Private Function IEIGetHelpFile(This As ErrorInfo, pBstrHelpFile As Long) As Long
    pBstrHelpFile = 0
    #If NOVBOOST Then
        Dim pHelpFile As Long
        pHelpFile = VarPtr(This.HelpFile)
        CopyMemory pBstrHelpFile, ByVal pHelpFile, 4
        CopyMemory ByVal pHelpFile, 0&, 4
    #Else
        VBoost.AssignSwap pBstrHelpFile, This.HelpFile
    #End If
End Function
Private Function IEIGetHelpContext(This As ErrorInfo, pdwHelpContext As Long) As Long
    pdwHelpContext = This.HelpContext
End Function
Private Function FuncAddr(ByVal pfn As Long) As Long
    FuncAddr = pfn
End Function

